home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / clisp-c.zoo / user1.lsp < prev    next >
Encoding:
Text File  |  1993-06-05  |  29.0 KB  |  757 lines
  1. ;;;; User-Interface, Teil 1
  2. ;;;; Eval-Env, Debugger, Stepper, Errors, Query-User
  3. ;;;; Bruno Haible 4.2.1990, 4.11.1991
  4.  
  5. (in-package "LISP")
  6. (export '(the-environment eval-env with-keyboard *keyboard-input*))
  7. (in-package "SYSTEM")
  8.  
  9. ;-------------------------------------------------------------------------------
  10. ;;                       THE-ENVIRONMENT und EVAL-ENV
  11.  
  12. ; THE-ENVIRONMENT wie in SCHEME
  13. (defvar *COMPILING* nil)
  14. (defun %the-environment (form env)
  15.   (declare (ignore form))
  16.   (setf (svref env 0) (svref (svref env 0) 2)) ; *evalhook*-Bindung streichen
  17.   env
  18. )
  19. (defmacro the-environment ()
  20.   (if *COMPILING*
  21.     (error #+DEUTSCH "~S ist in compiliertem Code unmöglich."
  22.            #+ENGLISH "~S is impossible in compiled code"
  23.            #+FRANCAIS "~S est impossible dans du code compilé."
  24.            'the-environment
  25.     )
  26.     `(let ((*evalhook* #'%the-environment)) 0)
  27. ) )
  28.  
  29. ; Das Toplevel-Environment
  30. (defparameter *toplevel-environment* (eval '(the-environment)))
  31. (defparameter *toplevel-denv* (svref *toplevel-environment* 4))
  32.  
  33. ; Evaluiert eine Form in einem Environment  
  34. (defun eval-env (form &optional (env *toplevel-environment*))
  35.   (evalhook form nil nil env)
  36. )
  37.  
  38. ;-------------------------------------------------------------------------------
  39. ;;                                 Debugger
  40.  
  41. (defvar *break-count* 0) ; Anzahl der aktiven Break-Schleifen (Fixnum >=0)
  42.  
  43. ; Hauptschleife:
  44. ; (driver
  45. ;   #'(lambda () (read-eval-print "> "))
  46. ; )
  47.  
  48. ; Help-Funktion:
  49. (defvar *key-bindings* nil) ; Liste von Tasten-Bindungen und Helpstrings
  50. (defun help ()
  51.   (dolist (s (reverse (remove-if-not #'stringp *key-bindings*)))
  52.     (write-string s #|*debug-io*|#)
  53. ) )
  54.  
  55. ; Bausteine der Break-Schleife:
  56. (defvar *debug-frame*)
  57. (defvar *debug-mode*)
  58. (defvar *frame-limit1* nil) ; untere Grenze für frame-down und frame-down-1
  59. (defvar *frame-limit2* nil) ; obere Grenze für frame-up und frame-up-1
  60. (defun frame-limit1 (frames-to-skip)
  61.   (let ((frame (the-frame)))
  62.     (let ((*frame-limit1* nil)
  63.           (*frame-limit2* nil))
  64.       (dotimes (i frames-to-skip) (setq frame (frame-up-1 frame 1)))
  65.     )
  66.     frame
  67. ) )
  68. (defun frame-limit2 ()
  69.   (let ((frame (the-frame)))
  70.     (let ((*frame-limit1* nil)
  71.           (*frame-limit2* nil))
  72.       (loop
  73.         (let ((nextframe (frame-up-1 frame 1)))
  74.           (when (or (eq nextframe frame) (driver-frame-p nextframe)) (return))
  75.           (setq frame nextframe)
  76.       ) )
  77.       (dotimes (i 2) (setq frame (frame-down-1 frame 1)))
  78.     )
  79.     frame
  80. ) )
  81. (defun debug-help () (help) (throw 'debug 'continue))
  82. (defun debug-unwind () (throw 'debug 'unwind))
  83. (defun debug-mode-1 () (setq *debug-mode* 1) (throw 'debug 'continue))
  84. (defun debug-mode-2 () (setq *debug-mode* 2) (throw 'debug 'continue))
  85. (defun debug-mode-3 () (setq *debug-mode* 3) (throw 'debug 'continue))
  86. (defun debug-mode-4 () (setq *debug-mode* 4) (throw 'debug 'continue))
  87. (defun debug-mode-5 () (setq *debug-mode* 5) (throw 'debug 'continue))
  88. (defun debug-where () (describe-frame *debug-frame*) (throw 'debug 'continue))
  89. (defun debug-up ()
  90.   (describe-frame
  91.     (setq *debug-frame* (frame-up-1 *debug-frame* *debug-mode*))
  92.   )
  93.   (throw 'debug 'continue)
  94. )
  95. (defun debug-top ()
  96.   (describe-frame
  97.     (setq *debug-frame* (frame-up *debug-frame* *debug-mode*))
  98.   )
  99.   (throw 'debug 'continue)
  100. )
  101. (defun debug-down ()
  102.   (describe-frame
  103.     (setq *debug-frame* (frame-down-1 *debug-frame* *debug-mode*))
  104.   )
  105.   (throw 'debug 'continue)
  106. )
  107. (defun debug-bottom ()
  108.   (describe-frame
  109.     (setq *debug-frame* (frame-down *debug-frame* *debug-mode*))
  110.   )
  111.   (throw 'debug 'continue)
  112. )
  113. (defun debug-backtrace (&optional (mode *debug-mode*))
  114.   (let ((frame (frame-down-1 (frame-up-1 *frame-limit1* mode) mode)))
  115.     (loop
  116.       (describe-frame frame)
  117.       (when (eq frame (setq frame (frame-up-1 frame mode))) (return))
  118.   ) )
  119.   (throw 'debug 'continue)
  120. )
  121. (defun debug-backtrace-1 () (debug-backtrace 1))
  122. (defun debug-backtrace-2 () (debug-backtrace 2))
  123. (defun debug-backtrace-3 () (debug-backtrace 3))
  124. (defun debug-backtrace-4 () (debug-backtrace 4))
  125. (defun debug-backtrace-5 () (debug-backtrace 5))
  126. (defun debug-redo ()
  127.   (redo-eval-frame *debug-frame*)
  128.   (throw 'debug 'continue)
  129. )
  130. (defun debug-return ()
  131.   (return-from-eval-frame *debug-frame*
  132.     (read-form #+DEUTSCH "Werte: "
  133.                #+ENGLISH "values: "
  134.                #+FRANCAIS "Valeurs : "
  135.   ) )
  136.   (throw 'debug 'continue)
  137. )
  138. (defun debug-continue () (throw 'debug 'quit))
  139.  
  140. #+ATARI (progn
  141. (defconstant commands0
  142.              (list
  143.                #+DEUTSCH "
  144. Help        = diese Sondertasten-Liste
  145. Backspace     ein Zeichen nach links löschen
  146. Delete        ein Zeichen nach rechts löschen
  147. Insert        eine Leerstelle einfügen
  148. ⇦             Cursor ein Zeichen nach links
  149. ⇨             Cursor ein Zeichen nach rechts
  150. Shift-⇦       Cursor an den Zeilenanfang
  151. Shift-⇨       Cursor ans Zeilenende
  152. Return, Enter beendet das Editieren dieser Zeile"
  153.                #+ENGLISH "
  154. Help        = this key list
  155. Backspace     deletes one character to the left
  156. Delete        deletes one character to the right
  157. Insert        inserts a space
  158. ⇦             moves the cursor one character to the left
  159. ⇨             moves the cursor one character to the right
  160. Shift-⇦       moves the cursor to the beginning of the line
  161. Shift-⇨       moves the cursor to the end of the line
  162. Return, Enter finishes editing of this line"
  163.                #+FRANCAIS "
  164. Help        = cette liste de touches spéciales
  165. Backspace     effacer un caractère vers la gauche
  166. Delete        effacer un caractère vers la droite
  167. Insert        ajouter un espace
  168. ⇦             Cursor vers la gauche
  169. ⇨             Cursor vers la droite
  170. Shift-⇦       Cursor au début de la ligne
  171. Shift-⇨       Cursor à la fin de la ligne
  172. Return, Enter finit les changements de cette ligne"
  173.                (cons #\Help   #'debug-help  )
  174. )            )
  175. (defconstant commands1
  176.              (list
  177.                #+DEUTSCH "
  178. Help   = dieses Menü
  179. Undo   = Abbruch, Rücksprung zur nächsthöheren Eingabeschleife
  180. F1     = alle Stack-Elemente inspizieren
  181. F2     = alle Frames inspizieren
  182. F3     = nur EVAL- und APPLY-Frames inspizieren (Default)
  183. F4     = nur APPLY-Frames inspizieren
  184. .      = diesen Frame inspizieren
  185. ⇧      = nächsthöheren Frame inspizieren
  186. Shift⇧ = obersten Frame inspizieren
  187. ⇩      = nächstneueren Frame inspizieren
  188. Shift⇩ = neuesten Frame inspizieren
  189. ShiftF1= alle Stack-Elemente auflisten
  190. ShiftF2= alle Frames auflisten
  191. ShiftF3= alle EVAL- und APPLY-Frames auflisten
  192. ShiftF4= alle APPLY-Frames auflisten
  193. F5     = Redo: Form im EVAL-Frame erneut auswerten
  194. F6     = Return: EVAL-Frame mit gegebenen Werten verlassen"
  195.                #+ENGLISH "
  196. Help   = this command list
  197. Undo   = abort to the next recent input loop
  198. F1     = inspect all the stack elements
  199. F2     = inspect all the frames
  200. F3     = inspect only EVAL and APPLY frames (default)
  201. F4     = inspect only APPLY frames
  202. .      = inspect this frame
  203. ⇧      = go up one frame, inspect it
  204. Shift⇧ = go to top frame, inspect it
  205. ⇩      = go down one frame, inspect it
  206. Shift⇩ = go to bottom (most recent) frame, inspect it
  207. ShiftF1= list all stack elements
  208. ShiftF2= list all frames
  209. ShiftF3= list all EVAL and APPLY frames
  210. ShiftF4= list all APPLY frames
  211. F5     = redo: re-evaluate form in EVAL frame
  212. F6     = return: leave EVAL frame, prescribing the return values"
  213.                #+FRANCAIS "
  214. Help   = ce menu-ci
  215. Undo   = arrêt, retour au niveau supérieur
  216. F1     = examiner tous les éléments de la pile
  217. F2     = examiner tous les «frames»
  218. F3     = examiner uniquement les «frames» EVAL et APPLY (par défaut)
  219. F4     = examiner uniquement les «frames» APPLY
  220. .      = examiner ce «frame»
  221. ⇧      = examiner un «frame» supérieur
  222. Shift⇧ = examiner le «frame» le plus élevé
  223. ⇩      = examiner un prochain «frame» plus récent (inférieur)
  224. Shift⇩ = examiner le «frame» le plus récent (le plus bas)
  225. ShiftF1= montrer tous les éléments de la pile
  226. ShiftF2= montrer tous les «frames»
  227. ShiftF3= montrer tous les «frames» EVAL et APPLY
  228. ShiftF4= montrer tous les «frames» APPLY
  229. F5     = Redo: réévaluer la forme dans le «frame» EVAL
  230. F6     = Return: quitter le «frame» EVAL avec certaines valeurs"
  231.                (cons #\Help   #'debug-help  )
  232.                (cons #\?      #'debug-help  )
  233.                (cons #\Undo   #'debug-unwind)
  234.                (cons #\F1     #'debug-mode-1)
  235.                (cons #\F2     #'debug-mode-2)
  236.                (cons #\F3     #'debug-mode-4)
  237.                (cons #\F4     #'debug-mode-5)
  238.                (cons #\.      #'debug-where )
  239.                (cons #\Up     #'debug-up    )
  240.                (cons #\S-Up   #'debug-top   )
  241.                (cons #\Down   #'debug-down  )
  242.                (cons #\S-Down #'debug-bottom)
  243.                (cons #\S-F1   #'debug-backtrace-1)
  244.                (cons #\S-F2   #'debug-backtrace-2)
  245.                (cons #\S-F3   #'debug-backtrace-4)
  246.                (cons #\S-F4   #'debug-backtrace-5)
  247. )            )
  248. (defconstant commands2
  249.              (list
  250.                (cons #\F5     #'debug-redo  )
  251.                (cons #\F6     #'debug-return)
  252. )            )
  253. (defconstant commands3
  254.              (list
  255.                #+DEUTSCH "
  256. F10    = Continue: Rest weiter abarbeiten"
  257.                #+ENGLISH "
  258. F10    = continue: continue evaluation"
  259.                #+FRANCAIS "
  260. F10    = Continue: continuer l'évaluation"
  261.                (cons #\F10  #'debug-continue)
  262. )            )
  263. )
  264. #-ATARI (progn
  265. (defconstant commands0
  266.              (list
  267.                #+DEUTSCH "
  268. Help = diese Liste
  269. Benutzen Sie die üblichen Editiermöglichkeiten."
  270.                #+ENGLISH "
  271. Help = this list
  272. Use the usual editing capabilities."
  273.                #+FRANCAIS "
  274. Help = cette liste
  275. Éditez de la façon habituelle."
  276.                (cons "Help"   #'debug-help  )
  277. )            )
  278. (defconstant commands1
  279.              (list
  280.                #+DEUTSCH "
  281. Help   = dieses Menü
  282. Abort  = Abbruch, Rücksprung zur nächsthöheren Eingabeschleife
  283. Unwind = Abbruch, Rücksprung zur nächsthöheren Eingabeschleife
  284. Mode-1 = alle Stack-Elemente inspizieren
  285. Mode-2 = alle Frames inspizieren
  286. Mode-3 = nur lexikalische Frames inspizieren
  287. Mode-4 = nur EVAL- und APPLY-Frames inspizieren (Default)
  288. Mode-5 = nur APPLY-Frames inspizieren
  289. Where  = diesen Frame inspizieren
  290. Up     = nächsthöheren Frame inspizieren
  291. Top    = obersten Frame inspizieren
  292. Down   = nächstneueren Frame inspizieren
  293. Bottom = neuesten Frame inspizieren
  294. Backtrace-1 = alle Stack-Elemente auflisten
  295. Backtrace-2 = alle Frames auflisten
  296. Backtrace-3 = alle lexikalische Frames auflisten
  297. Backtrace-4 = alle EVAL- und APPLY-Frames auflisten
  298. Backtrace-5 = alle APPLY-Frames auflisten
  299. Backtrace   = Stack auflisten im aktuellen Mode
  300. Redo   = Form im EVAL-Frame erneut auswerten
  301. Return = EVAL-Frame mit gegebenen Werten verlassen"
  302.                #+ENGLISH "
  303. Help   = this command list
  304. Abort  = abort to the next recent input loop
  305. Unwind = abort to the next recent input loop
  306. Mode-1 = inspect all the stack elements
  307. Mode-2 = inspect all the frames
  308. Mode-3 = inspect only lexical frames
  309. Mode-4 = inspect only EVAL and APPLY frames (default)
  310. Mode-5 = inspect only APPLY frames
  311. Where  = inspect this frame
  312. Up     = go up one frame, inspect it
  313. Top    = go to top frame, inspect it
  314. Down   = go down one frame, inspect it
  315. Bottom = go to bottom (most recent) frame, inspect it
  316. Backtrace-1 = list all stack elements
  317. Backtrace-2 = list all frames
  318. Backtrace-3 = list all lexical frames
  319. Backtrace-4 = list all EVAL and APPLY frames
  320. Backtrace-5 = list all APPLY frames
  321. Backtrace   = list stack in current mode
  322. Redo   = re-evaluate form in EVAL-Frame
  323. Return = leave EVAL-Frame, prescribing the return values"
  324.                #+FRANCAIS "
  325. Help   = ce menu-ci
  326. Abort  = arrêt, retour au niveau supérieur
  327. Unwind = arrêt, retour au niveau supérieur
  328. Mode-1 = examiner tous les éléments de la pile
  329. Mode-2 = examiner tous les «frames»
  330. Mode-3 = examiner uniquement les «frames» lexicaux
  331. Mode-4 = examiner uniquement les «frames» EVAL et APPLY (par défaut)
  332. Mode-5 = examiner uniquement les «frames» APPLY
  333. Where  = examiner ce «frame»
  334. Up     = examiner un «frame» supérieur
  335. Top    = examiner le «frame» le plus élevé
  336. Down   = examiner un prochain «frame» plus récent (inférieur)
  337. Bottom = examiner le «frame» le plus récent (le plus bas)
  338. Backtrace-1 = montrer tous les éléments de la pile
  339. Backtrace-2 = montrer tous les «frames»
  340. Backtrace-3 = montrer tous les «frames» lexicaux
  341. Backtrace-4 = montrer tous les «frames» EVAL et APPLY
  342. Backtrace-5 = montrer tous les «frames» APPLY
  343. Backtrace   = montrer la pile en mode actuel
  344. Redo   = réévaluer la forme dans le «frame» EVAL
  345. Return = quitter le «frame» EVAL avec certaines valeurs"
  346.                (cons "Help"   #'debug-help  )
  347.                (cons "?"      #'debug-help  )
  348.                (cons "Abort"  #'debug-unwind)
  349.                (cons "Unwind" #'debug-unwind)
  350.                (cons "Mode-1" #'debug-mode-1)
  351.                (cons "Mode-2" #'debug-mode-2)
  352.                (cons "Mode-3" #'debug-mode-3)
  353.                (cons "Mode-4" #'debug-mode-4)
  354.                (cons "Mode-5" #'debug-mode-5)
  355.                (cons "Where"  #'debug-where )
  356.                (cons "Up"     #'debug-up    )
  357.                (cons "Top"    #'debug-top   )
  358.                (cons "Down"   #'debug-down  )
  359.                (cons "Bottom" #'debug-bottom)
  360.                (cons "Backtrace-1" #'debug-backtrace-1)
  361.                (cons "Backtrace-2" #'debug-backtrace-2)
  362.                (cons "Backtrace-3" #'debug-backtrace-3)
  363.                (cons "Backtrace-4" #'debug-backtrace-4)
  364.                (cons "Backtrace-5" #'debug-backtrace-5)
  365.                (cons "Backtrace"   #'debug-backtrace  )
  366. )            )
  367. (defconstant commands2
  368.              (list
  369.                (cons "Redo"   #'debug-redo  )
  370.                (cons "Return" #'debug-return)
  371. )            )
  372. (defconstant commands3
  373.              (list
  374.                #+DEUTSCH "
  375. Continue = Rest weiter abarbeiten"
  376.                #+ENGLISH "
  377. Continue = continue evaluation"
  378.                #+FRANCAIS "
  379. Continue = continuer l'évaluation"
  380.                (cons "Continue" #'debug-continue)
  381. )            )
  382. )
  383.  
  384. ;; um Help-Kommando erweiterte Hauptschleife.
  385. (defun main-loop ()
  386.   (setq *break-count* 0)
  387.   (driver ; Driver-Frame aufbauen und folgende Funktion (endlos) ausführen:
  388.     #'(lambda ()
  389.         (catch 'debug ; die (throw 'debug ...) abfangen
  390.           (if ; Eingabezeile verlangen
  391.               (read-eval-print "> " (copy-list commands0))
  392.             ; T -> #<EOF>
  393.             (exit)
  394.             ; NIL -> Form bereits ausgewertet und ausgegeben
  395. ) )   ) ) )
  396. (setq *driver* #'main-loop)
  397.  
  398. ;; komfortable Break-Schleife. (Läuft nur in compiliertem Zustand!)
  399. (defun break-loop (continuable)
  400.   (tagbody
  401.     (let* ((*break-count* (1+ *break-count*))
  402.            (stream (make-synonym-stream '*debug-io*))
  403.            (*standard-input* stream)
  404.            (*standard-output* stream)
  405.            (prompt (with-output-to-string (s)
  406.                       (write *break-count* :stream s)
  407.                       (write-string ". Break" s)
  408.                       (write-string "> " s)
  409.            )       )
  410.            (*frame-limit1* (frame-limit1 12))
  411.            (*frame-limit2* (frame-limit2))
  412.            (*debug-mode* 4)
  413.            (*debug-frame* (frame-down-1 (frame-up-1 *frame-limit1* *debug-mode*) *debug-mode*))
  414.           )
  415.       (driver ; Driver-Frame aufbauen und folgende Funktion (endlos) ausführen:
  416.         #'(lambda ()
  417.             (case
  418.                 (catch 'debug ; die (throw 'debug ...) abfangen und analysieren
  419.                   (same-env-as *debug-frame* ; bei *debug-frame* gültiges Environment aufbauen
  420.                     #'(lambda ()
  421.                         (if ; Eingabezeile verlangen
  422.                             (read-eval-print prompt
  423.                               (nconc (copy-list commands1)
  424.                                      (when (eval-frame-p *debug-frame*) (copy-list commands2))
  425.                                      (when continuable (copy-list commands3))
  426.                             ) )
  427.                           ; T -> #<EOF>
  428.                           #|(throw 'debug 'quit)|# (go quit)
  429.                           ; NIL -> Form bereits ausgewertet und ausgegeben
  430.                           #|(throw 'debug 'continue)|#
  431.                 ) )   ) )
  432.               (unwind (go unwind))
  433.               (quit (go quit)) ; nur erreicht, falls continuable
  434.               (t ) ; alles andere, insbesondere continue
  435.     ) )   ) )
  436.     unwind (unwind-to-driver)
  437.     quit
  438. ) )
  439. (setq *break-driver* #'break-loop)
  440.  
  441. ;-------------------------------------------------------------------------------
  442. ;;        komfortabler Stepper. (Läuft nur in compiliertem Zustand!)
  443.  
  444. (defvar *step-level* 0) ; momentane Step-Tiefe
  445. (defvar *step-quit* most-positive-fixnum) ; kritische Step-Tiefe:
  446.   ; sobald diese unterschritten wird, wacht der Stepper wieder auf.
  447. (defvar *step-watch* nil) ; Abbruchbedingung
  448.  
  449. ; (STEP form), CLTL S. 441
  450. (defmacro step (form)
  451.   `(let* ((*step-level* 0)
  452.           (*step-quit* most-positive-fixnum)
  453.           (*step-watch* nil)
  454.           (*evalhook* #'step-hook-fn))
  455.      ,form
  456.    )
  457. )
  458.  
  459. #+ATARI
  460. (defconstant commands4
  461.              (list
  462.                #+DEUTSCH "
  463. F7     = Step into form: diese Form im Einzelschrittmodus ausführen
  464. F8     = Step over form: diese Form auf einmal ausführen
  465. F9     = Step over this level: bis zum Aufrufer auf einmal ausführen
  466. F10    = Continue: Einzelschrittmodus abschalten, Rest ausführen
  467. Shift F7-F10: dito, jedoch mit Angabe einer Abbruchbedingung"
  468.                #+ENGLISH "
  469. F7     = step into form: evaluate this form in single step mode
  470. F8     = step over form: evaluate this form at once
  471. F9     = step over this level: evaluate at once up to the next return
  472. F10    = continue: switch off single step mode, continue evaluation
  473. Shift F7-F10: same as above, specify a condition when to stop"
  474.                (cons #\F7    #'(lambda () (throw 'stepper 'into)))
  475.                (cons #\F8    #'(lambda () (throw 'stepper 'over)))
  476.                (cons #\F9    #'(lambda () (throw 'stepper 'over-this-level)))
  477.                (cons #\F10   #'(lambda () (throw 'stepper 'continue)))
  478.                (cons #\S-F7  #'(lambda () (throw 'stepper (values 'into t))))
  479.                (cons #\S-F8  #'(lambda () (throw 'stepper (values 'over t))))
  480.                (cons #\S-F9  #'(lambda () (throw 'stepper (values 'over-this-level t))))
  481.                (cons #\S-F10 #'(lambda () (throw 'stepper (values 'continue t))))
  482. )            )
  483. #-ATARI
  484. (defconstant commands4
  485.              (list
  486.                #+DEUTSCH "
  487. Step     = Step into form: diese Form im Einzelschrittmodus ausführen
  488. Next     = Step over form: diese Form auf einmal ausführen
  489. Over     = Step over this level: bis zum Aufrufer auf einmal ausführen
  490. Continue = Einzelschrittmodus abschalten, Rest ausführen
  491. Step-until, Next-until, Over-until, Continue-until:
  492.            dito, jedoch mit Angabe einer Abbruchbedingung"
  493.                #+ENGLISH "
  494. Step     = step into form: evaluate this form in single step mode
  495. Next     = step over form: evaluate this form at once
  496. Over     = step over this level: evaluate at once up to the next return
  497. Continue = switch off single step mode, continue evaluation
  498. Step-until, Next-until, Over-until, Continue-until:
  499.            same as above, specify a condition when to stop"
  500.                (cons "Step"     #'(lambda () (throw 'stepper 'into)))
  501.                (cons "Next"     #'(lambda () (throw 'stepper 'over)))
  502.                (cons "Over"     #'(lambda () (throw 'stepper 'over-this-level)))
  503.                (cons "Continue" #'(lambda () (throw 'stepper 'continue)))
  504.                (cons "Step-until"     #'(lambda () (throw 'stepper (values 'into t))))
  505.                (cons "Next-until"     #'(lambda () (throw 'stepper (values 'over t))))
  506.                (cons "Over-until"     #'(lambda () (throw 'stepper (values 'over-this-level t))))
  507.                (cons "Continue-until" #'(lambda () (throw 'stepper (values 'continue t))))
  508. )            )
  509.  
  510. (defun step-values (values)
  511.   (let ((*standard-output* *debug-io*))
  512.     (terpri #|*debug-io*|#)
  513.     (write-string #+DEUTSCH "Step "
  514.                   #+ENGLISH "step "
  515.                   #|*debug-io*|#
  516.     )
  517.     (write *step-level* #|:stream *debug-io*|#)
  518.     (write-string " ==> " #|*debug-io*|#)
  519.     (case (length values)
  520.       (0 (write-string #+DEUTSCH "Keine Werte"
  521.                        #+ENGLISH "no values"
  522.                        #|*debug-io*|#
  523.       )  )
  524.       (1 (write-string #+DEUTSCH "Wert: "
  525.                        #+ENGLISH "value: "
  526.                        #|*debug-io*|#
  527.          )
  528.          (write (car values) #|:stream *debug-io*|#)
  529.       )
  530.       (t (write (length values) #|:stream *debug-io*|#)
  531.          (write-string #+DEUTSCH " Werte: "
  532.                        #+ENGLISH " values: "
  533.                        #|*debug-io*|#
  534.          )
  535.          (do ((L values))
  536.              ((endp L))
  537.            (write (pop L) #|:stream *debug-io*|#)
  538.            (unless (endp L) (write-string ", " #|*debug-io*|#))
  539.       )  )
  540.   ) )
  541.   (values-list values)
  542. )
  543.  
  544. (defun step-hook-fn (form &optional (env *toplevel-environment*))
  545.   (let ((*step-level* (1+ *step-level*)))
  546.     (when (>= *step-level* *step-quit*) ; Solange *step-level* >= *step-quit*
  547.       (if (and *step-watch* (funcall *step-watch*)) ; und kein Breakpoint,
  548.         (setq *step-quit* most-positive-fixnum)
  549.         (return-from step-hook-fn ; ist der Stepper passiv
  550.           (evalhook form nil nil env) ; (d.h. er evaluiert die Form einfach)
  551.     ) ) )
  552.     (tagbody
  553.       (let* ((stream (make-synonym-stream '*debug-io*))
  554.              (*standard-input* stream)
  555.              (*standard-output* stream)
  556.              (prompt (with-output-to-string (s)
  557.                        (write-string "Step " s)
  558.                        (write *step-level* :stream s)
  559.                        (write-string "> " s)
  560.              )       )
  561.              (*frame-limit1* (frame-limit1 11))
  562.              (*frame-limit2* (frame-limit2))
  563.              (*debug-mode* 4)
  564.              (*debug-frame* (frame-down-1 (frame-up-1 *frame-limit1* *debug-mode*) *debug-mode*))
  565.             )
  566.         (fresh-line #|*debug-io*|#)
  567.         (write-string #+DEUTSCH "Step "
  568.                       #+ENGLISH "step "
  569.                       #|*debug-io*|#
  570.         )
  571.         (write *step-level* #|:stream *debug-io*|#)
  572.         (write-string " --> " #|*debug-io*|#)
  573.         (write form #|:stream *debug-io*|# :length 4 :level 3)
  574.         (loop
  575.           (multiple-value-bind (what watchp)
  576.             (catch 'stepper ; die (throw 'stepper ...) abfangen und analysieren
  577.               (driver ; Driver-Frame aufbauen und folgende Funktion endlos ausführen:
  578.                 #'(lambda ()
  579.                     (case
  580.                         (catch 'debug ; die (throw 'debug ...) abfangen und analysieren
  581.                           (same-env-as *debug-frame* ; bei *debug-frame* gültiges Environment aufbauen
  582.                             #'(lambda ()
  583.                                 (if ; Eingabezeile verlangen
  584.                                     (read-eval-print prompt
  585.                                       (nconc (copy-list commands1)
  586.                                              (when (eval-frame-p *debug-frame*) (copy-list commands2))
  587.                                              (copy-list commands4)
  588.                                     ) )
  589.                                   ; T -> #<EOF>
  590.                                   (go continue)
  591.                                   ; NIL -> Form bereits ausgewertet und ausgegeben
  592.                                   #|(throw 'debug 'continue)|#
  593.                         ) )   ) )
  594.                       (unwind (go unwind))
  595.                       (t ) ; alles andere, insbesondere continue
  596.             ) )   ) )
  597.             (when watchp
  598.               (let ((form (read-form #+DEUTSCH "Abbruchbedingung: "
  599.                                      #+ENGLISH "condition when to stop: "
  600.                    ))     )
  601.                 (setq *step-watch* ; Funktion, die 'form' bei *debug-frame* auswertet
  602.                   (eval-at *debug-frame* `(function (lambda () ,form)))
  603.             ) ) )
  604.             (case what
  605.               (into (go into))
  606.               (over (go over))
  607.               (over-this-level (go over-this-level))
  608.               (continue (go continue))
  609.             )
  610.       ) ) )
  611.       unwind
  612.         (unwind-to-driver)
  613.       into
  614.         (return-from step-hook-fn
  615.           (step-values
  616.             (multiple-value-list (evalhook form #'step-hook-fn nil env))
  617.         ) )
  618.       over-this-level
  619.         (setq *step-quit* *step-level*) ; Stepper in Schlafzustand schalten
  620.       over
  621.         (return-from step-hook-fn
  622.           (step-values
  623.             (multiple-value-list (evalhook form nil nil env))
  624.         ) )
  625.       continue
  626.         (setq *step-quit* 0)
  627.         (go over)
  628. ) ) )
  629.  
  630. ;-------------------------------------------------------------------------------
  631. ;;                                  Errors
  632.  
  633. ; *ERROR-HANDLER* sollte NIL oder eine Funktion sein, die übergeben bekommt:
  634. ; - NIL (bei ERROR) bzw. continue-format-string (bei CERROR),
  635. ; - error-format-string,
  636. ; - Argumente dazu,
  637. ; und die nur zurückkehren sollte, falls das erstere /=NIL ist.
  638. (defvar *error-handler* nil)
  639.  
  640. ; (CERROR continue-format-string error-format-string {arg}*), CLTL S. 430
  641. (defun cerror (continue-format-string error-format-string &rest args)
  642.   (if *error-handler*
  643.     (apply *error-handler*
  644.            (or continue-format-string t) error-format-string args
  645.     )
  646.     (progn
  647.       (terpri *error-output*)
  648.       (write-string "** - Continuable Error" *error-output*)
  649.       (terpri *error-output*)
  650.       (apply #'format *error-output* error-format-string args)
  651.       (terpri *error-output*)
  652.       (if (interactive-stream-p *debug-io*)
  653.         (progn
  654.           #+ATARI (write-string #+DEUTSCH "Wenn Sie (mit F10) fortfahren: "
  655.                                 #+ENGLISH "If you continue (by pressing F10): "
  656.                                 *error-output*
  657.                   )
  658.           #-ATARI (write-string #+DEUTSCH "Wenn Sie (mit Continue) fortfahren: "
  659.                                 #+ENGLISH "If you continue (by typing 'continue'): "
  660.                                 *error-output*
  661.                   )
  662.           (apply #'format *error-output* continue-format-string args)
  663.           (funcall *break-driver* t)
  664.         )
  665.         (apply #'format *error-output* continue-format-string args)
  666.   ) ) )
  667.   nil
  668. )
  669.  
  670. (defvar *break-on-warnings* nil)
  671. ; (WARN format-string {arg}*), CLTL S. 432
  672. (defun warn (format-string &rest args)
  673.   (terpri *error-output*)
  674.   (write-string #+DEUTSCH "WARNUNG:"
  675.                 #+ENGLISH "WARNING:"
  676.                 *error-output*
  677.   )
  678.   (terpri *error-output*)
  679.   (apply #'format *error-output* format-string args)
  680.   (when *break-on-warnings* (funcall *break-driver* t))
  681.   nil
  682. )
  683.  
  684. ; (BREAK [format-string {arg}*]), CLTL S. 432
  685. (defun break (&optional (format-string "*** - Break") &rest args)
  686.   (terpri *error-output*)
  687.   (apply #'format *error-output* format-string args)
  688.   (funcall *break-driver* t)
  689.   nil
  690. )
  691.  
  692. ;-------------------------------------------------------------------------------
  693. ;;                            Querying the user
  694.  
  695. ; (Y-OR-N-P [format-string {arg}*]), CLTL S. 407
  696. (defun y-or-n-p (&optional format-string &rest args)
  697.   (when format-string
  698.     (fresh-line *query-io*)
  699.     (apply #'format *query-io* format-string args)
  700.     (write-string #+DEUTSCH " (j/n) "
  701.                   #+ENGLISH " (y/n) "
  702.                   *query-io*
  703.   ) )
  704.   (loop
  705.     (let ((line (string-left-trim " " (read-line *query-io*))))
  706.       (when (plusp (length line))
  707.         (case (char-upcase (char line 0))
  708.           (#\N (return nil))
  709.           ((#\J #\Y) (return t))
  710.     ) ) )
  711.     (terpri *query-io*)
  712.     (write-string #+DEUTSCH "Bitte mit j oder n antworten: "
  713.                   #+ENGLISH "Please answer with y or n : "
  714.                   *query-io*
  715. ) ) )
  716.  
  717. ; (YES-OR-NO-P [format-string {arg}*]), CLTL S. 408
  718. (defun yes-or-no-p (&optional format-string &rest args)
  719.   (when format-string
  720.     (fresh-line *query-io*)
  721.     (apply #'format *query-io* format-string args)
  722.     (write-string #+DEUTSCH " (ja/nein) "
  723.                   #+ENGLISH " (yes/no) "
  724.                   *query-io*
  725.   ) )
  726.   (loop
  727.     (clear-input *query-io*)
  728.     (let* ((line (string-trim " " (read-line *query-io*)))
  729.            (h (assoc line '(("ja" . t) ("nein" . nil) ("yes" . t) ("no" . nil))
  730.                           :test #'string-equal
  731.           ))  )
  732.       (when h (return (cdr h)))
  733.     )
  734.     (terpri *query-io*)
  735.     (write-string #+DEUTSCH "Bitte mit ja oder nein antworten: "
  736.                   #+ENGLISH "Please answer with yes or no : "
  737.                   *query-io*
  738. ) ) )
  739.  
  740. #-AMIGA
  741. (progn
  742.   (defvar *keyboard-input*)
  743.   (defmacro with-keyboard (&body body)
  744.     #+(or ATARI DOS OS/2) ; *keyboard-input* existiert schon
  745.       `(PROGN ,@body)
  746.     #+(or UNIX VMS)
  747.       `(UNWIND-PROTECT
  748.          (PROGN
  749.            (SYS::TERMINAL-RAW *TERMINAL-IO* T)
  750.            ,@body
  751.          )
  752.          (SYS::TERMINAL-RAW *TERMINAL-IO* NIL)
  753.        )
  754.   )
  755. )
  756.  
  757.